home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / fools.lzh / extra.scm < prev    next >
Encoding:
Text File  |  1990-03-02  |  8.6 KB  |  284 lines
  1. ;;; extra functions and macros
  2.   
  3. (define (list-ref l k)
  4.   ;; kth element of l
  5.   (and (pair? l) (if (<= k 0) (car l) (list-ref (cdr l) (- k 1)))))
  6.  
  7. (define (list-tail l k)
  8.   ;; sublist of l omitting the first k elements
  9.   (and (pair? l) (if (<= k 0) l (list-tail (cdr l) (- k 1)))))
  10.  
  11. (define (last-pair l)
  12.   ;; the last pair of the list
  13.   (if (pair? (cdr l)) (last-pair (cdr l)) l))
  14.  
  15. ;; ASCII based character predicates
  16. (define (char-upper-case? c) (and (char>=? c #\A) (char<=? c #\Z)))
  17. (define (char-lower-case? c) (and (char>=? c #\a) (char<=? c #\z)))
  18. (define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))
  19. (define (char-numeric? c) (and (char>=? c #\0) (char <=? c #\9)))
  20. (define (char-whitespace? c) (memv c '(#\space #\tab #\newline)))
  21. (define (char-upcase c) (if (char-lower-case? c) (integer->char (- c 32)) c))
  22. (define (char-downcase c) (if (char-upper-case? c) (integer->char (+ c 32)) c))
  23.  
  24. (define gensym
  25.   ;; generate unique symbols
  26.   (let ((counter 0))
  27.     (lambda () (begin1
  28.         (string->uninterned-symbol
  29.          (string-append "G" (integer->string counter #\d)))
  30.         (set! counter (+ counter 1))))))
  31.  
  32. (define-macro (while pred . body)
  33.   ;; while pred is true, evaluate the expressions in body and return the
  34.   ;; result of the last expression evaluated (or #f if none were evaluated)
  35.   (let ((while-loop (gensym))
  36.     (while-res (gensym)))
  37.     `(letrec ((,while-loop
  38.            (lambda (,while-res)
  39.          (if ,pred (,while-loop (begin ,@body)) ,while-res))))
  40.        (,while-loop #f))))
  41.  
  42. (define-macro (when pred . body)
  43.   ;; evaluate body if pred is true
  44.   `(and ,pred (begin ,@body)))
  45.  
  46. (define-macro (unless pred . body)
  47.   ;; evaluate body if pred is false
  48.   `(or ,pred (begin ,@body)))
  49.  
  50. (define-macro (case key . clauses)
  51.   ;; conditionally execute the clause eqv? to key
  52.   (define (case-make-clauses key)
  53.     `(cond ,@(map
  54.               (lambda (clause)
  55.                 (if (pair? clause)
  56.                     (let ((case (car clause))
  57.                           (exprs (cdr clause)))
  58.                       (cond ((eq? case 'else)
  59.                              `(else ,@exprs))
  60.                             ((pair? case)
  61.                              (if (= (length case) 1)
  62.                                  `((eqv? ,key ',(car case)) ,@exprs)
  63.                                  `((memv ,key ',case) ,@exprs)))
  64.                             (else
  65.                              `((eqv? ,key ',case) ,@exprs))))
  66.                     (error 'case "invalid syntax in ~a" clause)))
  67.               clauses)))
  68.   (if (pair? key)
  69.       (let ((newkey (gensym)))
  70.         `(let ((,newkey ,key))
  71.            ,(case-make-clauses newkey)))
  72.       (case-make-clauses key)))
  73.  
  74. (define-macro (let* bindings . body)
  75.   ;; sequentially perform the bindings then evaluate the expressions in body
  76.   ;; within the new scope defined by the bindings
  77.   (if (null? bindings)
  78.       `(sequence ,@body)
  79.       `(let ((,(caar bindings) ,(cadar bindings)))
  80.      (let* ,(cdr bindings) ,@body))))
  81.  
  82. (define-macro (let bindings .  body)
  83.   ;; extend let to handle (let name bindings expr ...)
  84.   (if (symbol? bindings)
  85.       ;; named let
  86.       `(letrec ((,bindings
  87.          (lambda ,(map car (car body)) ,@(cdr body))))
  88.      (,bindings ,@(map cadr (car body))))
  89.       `((lambda ,(map car bindings) ,@body) ,@(map cadr bindings))))
  90.  
  91. (define list-join
  92.   ;; pair-wise join the lists in lsts (the output is in reverse order)
  93.   (letrec ((join-iter
  94.         (lambda (lsts out)
  95.           (if (ormap null? lsts)
  96.           out
  97.           (join-iter (map cdr lsts) (cons (map car lsts) out))))))
  98.     (lambda (lsts) (join-iter lsts '()))))
  99.  
  100. (define map
  101.   ;; redefine map to handle multiple argument lists
  102.   (letrec ((map-loop
  103.         (lambda (fcn lst out)
  104.           (if (null? lst)
  105.           out
  106.           (map-loop fcn (cdr lst) (cons (fcn (car lst)) out))))))
  107.     (lambda (fcn lst . rest)
  108.       (if (null? rest)
  109.       (reverse (map-loop fcn lst '()))
  110.       (map-loop (lambda (x) (apply fcn x))
  111.             (list-join (cons lst rest))
  112.             '())))))
  113.  
  114. (define for-each
  115.   ;; redefine for-each to handle multiple argument lists
  116.   (letrec ((for-loop
  117.         (lambda (fcn lst)
  118.           (if (null? lst)
  119.           #t
  120.           (begin (fcn (car lst)) (for-loop fcn (cdr lst)))))))
  121.     (lambda (fcn lst . rest)
  122.       (if (null? rest)
  123.       (for-loop fcn lst)
  124.       (for-loop (lambda (x) (apply fcn x))
  125.             (reverse (list-join (cons lst rest))))))))
  126.  
  127. (define ormap
  128.   (letrec ((ormap1
  129.         (lambda (pred lst last)
  130.           (or last
  131.           (and (pair? lst)
  132.                (ormap1 pred (cdr lst) (pred (car lst))))))))
  133.     (lambda (pred lst . rest)
  134.       (if (null? rest)
  135.       (ormap1 pred lst #f)
  136.       (ormap1 (lambda (x) (apply pred x))
  137.           (reverse (list-join (cons lst rest)))
  138.           #f)))))
  139.  
  140. (define andmap
  141.   (letrec ((andmap1
  142.         (lambda (pred lst last)
  143.           (if last
  144.           (if (pair? lst)
  145.               (andmap1 pred (cdr lst) (pred (car lst)))
  146.               last)))))
  147.     (lambda (pred lst . rest)
  148.       (if (null? rest)
  149.       (andmap1 pred lst #t)
  150.       (andmap1 (lambda (x) (apply pred x))
  151.            (reverse (list-join (cons lst rest)))
  152.            #t)))))
  153.  
  154. (define (string . chars)
  155.   ;; build a string out of the characters in chars
  156.   (list->string chars))
  157.  
  158. (define duplicates
  159.   ;; find the duplicates in a list using eq?
  160.   (letrec ((dupes
  161.         (lambda (l f d)
  162.           (if (null? l) d
  163.           (let ((elt (car l)))
  164.             (if (memq elt f)
  165.             (if (memq elt d)
  166.                 (dupes (cdr l) f d)
  167.                 (dupes (cdr l) f (cons elt d)))
  168.             (dupes (cdr l) (cons elt f) d)))))))
  169.     (lambda (l) (dupes l '() '()))))
  170.  
  171. ;; the top-level environment
  172. (define user-initial-environment (package-environment 'top-level))
  173.  
  174. ;;; streams
  175.  
  176. (define-macro delay
  177.   (letrec ([make-promise
  178.         (lambda (proc)
  179.           (let ((already-run? #f) (result #f))
  180.         (lambda ()
  181.           (if already-run? result
  182.               (begin (set! result (proc))
  183.                  (set! already-run? #t)
  184.                  result)))))])
  185.     (lambda (expr) `(,make-promise (lambda () ,expr)))))
  186.  
  187. (define (force expr) (expr))
  188.  
  189. (define-macro (cons-stream head tail) `(cons ,head (delay ,tail)))
  190. (define head car)
  191. (define (tail stream) (force (cdr stream)))
  192. (define the-empty-stream nil)
  193.  
  194. (define (map-stream proc stream)
  195.   (if (empty-stream? stream) the-empty-stream
  196.       (cons-stream (proc (head stream))
  197.                  (map-stream proc (tail stream)))))
  198.  
  199. (define empty-stream? null?)
  200.  
  201. (define (nth-stream n s)
  202.   (and (pair? s) (if (< n 1) (head s) (nth-stream (- n 1) (tail s)))))
  203.  
  204. (define (map-stream fcn s)
  205.   (if (empty-stream? s) the-empty-stream
  206.       (cons-stream (fcn (head s)) (map-stream fcn (tail s)))))
  207.  
  208. (define (filter-stream pred s)
  209.   (cond ((empty-stream? s) the-empty-stream)
  210.     ((pred (head s)) (cons-stream (head s) (filter-stream pred (tail s))))
  211.     (else (filter-stream pred (tail s)))))
  212.  
  213. ;; printf and fprintf
  214. (define (fprintf file fmt . args)
  215.   (letrec ((len (string-length fmt))
  216.        (get-arg
  217.         (lambda ()
  218.           (if (null? args)
  219.           (error 'fprintf "missing arguments")
  220.           (begin1 (car args) (set! args (cdr args))))))
  221.        (process
  222.         (lambda (ptr)
  223.           (if (< ptr len)
  224.           (let ((c (string-ref fmt ptr)))
  225.             (cond [(char=? c #\~)
  226.                (case (string-ref fmt (+ ptr 1))
  227.                  [#\s (write (get-arg) file)]
  228.                  [#\a (display (get-arg) file)]
  229.                  [#\c (write-char (get-arg) file)]
  230.                  [#\% (newline file)]
  231.                  [#\~ (write-char #\~ file)]
  232.                  [else
  233.                   (write-char (string-ref fmt (+ ptr 1)) file)])
  234.                (process (+ ptr 2))]
  235.               [else
  236.                (write-char c file)
  237.                (process (+ ptr 1))]))
  238.           (if (not (null? args))
  239.               (error 'fprintf "supplied extra arguments ~s" args))))))
  240.     (process 0)))
  241. (define (printf fmt . args)
  242.   (apply fprintf (list* (current-output-port) fmt args)))
  243.  
  244. (define (error proc fmt . args)
  245.   (printf "~a:  " proc)
  246.   (apply printf (list* fmt args))
  247.   (newline)
  248.   (abort))
  249.  
  250. ;;; packages
  251.  
  252. ;; where to look for packages (include a trailing slash)
  253. (define *package-path* '("./" "~/scm/" "./bench" "/usr/local/lib/fools/"))
  254.  
  255. ;; file extension for packages
  256. (define *package-ext* ".scm")
  257.  
  258. ;; packages loaded
  259. (define *packages* nil)
  260.  
  261. (define (find-package package)
  262.   ;; find the file name of package
  263.   (define (for-each-path paths)
  264.     (if (null? paths) #f
  265.     (let ((fname (string-append (car paths) package)))
  266.       (if (file-access fname "r") fname
  267.           (for-each-path (cdr paths))))))
  268.   (for-each-path *package-path*))
  269.  
  270. (define (require package)
  271.   ;; load package if not already loaded
  272.   (if (memq package *packages*) #t
  273.       (let ((filename (find-package (string-append package *package-ext*))))
  274.     (if filename
  275.         (begin (printf ";;; loading ~s~%" filename) (load filename))
  276.         (error 'require "can't find package ~s in ~s"
  277.            package  *package-path*)))))
  278.  
  279. (define (provide package)
  280.   ;; note somewhere that package is loaded
  281.   (if (memq package *packages*)
  282.       (error 'provide "package ~s is already loaded" package)
  283.       (sequence (set! *packages* (cons package *packages*)) #t)))
  284.